home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 22
/
Cream of the Crop 22.iso
/
doom
/
quake1.zip
/
XPAK041.ZIP
/
XPAK041.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-09-30
|
36KB
|
1,065 lines
program xPak; (* .PAK file manipulator *)
{$M 16384,102400,655360} {Enough heap to load PAK0.PAK directory min}
uses wildmat,dos,crt;
const
LUMP_NAME_SIZE = $40-8;
END_CHARS = [#10,#0,#32,#13];
PAK_HEADER = 'PACK';
PAK_PROTECTED = 'PAK0.PAK';
MAX_BLOCK_SIZE:word = 65528;
{HALT codes, not fully implemented yet}
HALT_PARSE = 1;
HALT_SAFETY = 3;
HALT_QUIT = 4;
type
Buffer= array[1..65528] of byte;
LumpNameType= array[1..LUMP_NAME_SIZE] of char;
Modes=(None,List,Extract,Add,Remove,Rename,Merge);
DirEntry=record
Lumpname : LumpNameType;
Pos : Longint;
Size : LongInt;
end;
PFileSpecList=^TFileSpecList;
TFileSpecList=record
FileSpec : string[140];
LumpName : string[LUMP_NAME_SIZE];
Remapped : boolean;
included : boolean;
Next : PFileSpecList;
end;
PMasterDir=^TMasterDir;
TMasterDir=record {212 bytes}
Dir : DirEntry;
Filename : string[140];
Prev : PMasterDir;
Next : PMasterDir;
end;
TFlags=record
Override : boolean;
Verbose : boolean;
Force : boolean;
Interact : boolean;
Query : boolean;
AccessPAK: boolean;
Backup : boolean;
JustName : boolean;
Debug : boolean;
end;
var
Flags: TFlags;
{ o: text;}
procedure Help;
begin
Writeln('usage: xpak <pakfile> -l|-e|-a|-r|-n [lumpname:]filespec [switches]');
Writeln;
Writeln('Command line must contain *one* of the following switches:');
writeln(' (r) = read; (c) = create; (m) = modify');
writeln(' -l (r) List contents of PAK file');
writeln(' -e (r) Extract specified files to directory tree');
writeln(' -a (c) Add specified files to PAK file (also create and update files)');
writeln(' -r (m) Remove specified lumps');
writeln(' -n (m) Rename lump in PAK file (renames to :filename');
writeln('Notice: -u and old -c have been removed. They have been integrated into -a');
writeln(#13#10,'Press any key for next page');ReadKey;
writeln(#13#10,'Modification switches:');
writeln(' -o Overrides some of the safety features in xpak. These include');
writeln(' not writing to ID1.PAK and requiring existance of ./quake.exe');
writeln(' -j (with -l) display just names only (useful to create @file lists)');
writeln(' -v verbose mode. Display names of lumps during processing.');
writeln(' -d debug mode. Displays all sorts of useless debugging info.');
writeln(' -i (with -e) Interactive mode. Prompt to overwrite files');
writeln(' -f (with -e) Force overwrites. Default is to skip existing files');
writeln(' # -q Query mode, ask before adding/extracting/removing each file');
writeln(' # -b backup PAK file before modification / existing extract targets');
writeln;
writeln('Lump names may be specified as free * and ? wildcards, but filenames');
writeln('(excludes -e) require DOS style paths and wildcards. To access a lump name');
writeln('with a different filename, use the syntax lumpname:filename. Wildcards not');
writeln('allowed. File lists can be referenced as @filename. # denotes comment line');
writeln;
writeln('Remember that this is an early version, and may have ''problems'' =) Note also');
writeln('that xpak is now more-or-less unsupported, as I am working on a rewrite, sixpak');
halt;
end;
procedure Lower4(var Str: String);
InLine( {Adapted From SWAG}
$8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('A')/Ord('Z')/
$AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$44/$FF/$20/$E2/$F1/$8E/$DA);
procedure cvBackSlash(var ForeStr: string);
var i: byte;
begin
for i:=1 to Length(ForeStr) do
if ForeStr[i]='/' then ForeStr[i]:='\';
end;
procedure cvForeSlash(var BackStr: string);
var i: byte;
begin
for i:=1 to Length(BackStr) do
if BackStr[i]='\' then BackStr[i]:='/';
end;
procedure SetStr(var st:string; const ar:LumpNameType);
var
i: byte;
begin
st:='';
for i:=1 to LUMP_NAME_SIZE do
begin
if ar[i] in END_CHARS then begin dec(i); break end;
st[i]:=ar[i];
end;
st[0]:=Char(i);
end;
procedure SetArr(var ar: LumpNameType; const st:string);
var
i,j: byte;
begin
FillChar(ar,SizeOf(ar),0);
j:=Length(st);
if Length(st)>LUMP_NAME_SIZE then j:=LUMP_NAME_SIZE;
for i:=1 to j do
ar[i]:=st[i];
end;
function Exist(const filename:string): boolean;
var
DirInfo:SearchRec;
begin
FindFirst(filename,Anyfile,DirInfo);
Exist:=(DosError=0);
end;
function MakePAKFilename(const oldname:string):string;
begin
if Pos('.',oldname)>0 then
MakePAKFilename:=oldname
else
MakePAKFilename:=oldname+'.pak';
end;
procedure AddFileSpec(fs:string; yn: boolean; var TempPos: PFileSpecList);
var
spec,lump:string;
cpos: byte;
remap:boolean;
begin
lump:=fs;spec:=fs;
cpos:=pos(':',fs);
remap:=false;
if cpos>0 then
begin
if pos('*',fs)>0 then
begin writeln('addspec: no wildcards allowed with alternate filenames (yet)'); exit end;
if pos('?',fs)>0 then
begin writeln('addspec: no wildcards allowed with alternate filenames (yet)'); exit end;
lump:=Copy(fs,1,cpos-1);
spec:=Copy(fs,cpos+1,255);
remap:=true;
end;
New(TempPos^.Next);
TempPos:=TempPos^.Next;
cvBackslash(spec);
cvForeslash(lump);
Lower4(lump);
TempPos^.Filespec:=spec;
TempPos^.Lumpname:=lump;
TempPos^.Included:=yn;
TempPos^.Remapped:=remap;
TempPos^.Next:=nil;
end;
procedure FromFile(fn:string;Incl: boolean; var ListTemp: PFileSpecList);
var
ff: text;
fs: string;
begin
if fn[1]='@' then Delete(fn,1,1);
Assign(ff,fn);
{$I-}
Reset(ff);
if IOResult<>0 then
begin writeln('parse: unable to open filespec list file.'); exit end;
{$I+}
while not eof(ff) do
begin
ReadLn(ff,fs);
if fs<>'' then
if fs[1]<>'#' then
if fs[1]='!' then
AddFileSpec(Copy(fs,2,Length(fs)-1),not incl,ListTemp)
else
AddFileSpec(fs,incl,ListTemp);
end;
end;
function CheckParams(var MainPAK:string; var Files: PFileSpecList):Modes;
var
Param:string;
i:byte;
TempSpec:PFileSpecList;
SpecStart: PFileSpecList;
TempMode: Modes;
Include: boolean;
begin
TempMode:=None;Include:=True;MainPAK:='';
FillChar(Flags,SizeOf(Flags),0);
New(Files); TempSpec:=Files;
TempSpec^.Filespec:='*';
TempSpec^.Included:=True;
TempSpec^.Next:=nil;
if ParamCount=0 then begin writeln('Type `xpak -?` for help.');halt end;
for i:=1 to ParamCount do
begin
Param:=ParamStr(i);
If Param[1]='-' then
if Length(Param)=1 then begin Writeln('parse: bad parameter ',Param);halt(1) end
else
Case UpCase(Param[2]) of
'?': Help;
'B': Flags.Backup:=True;
'D': Flags.Debug:=True;
'F': Flags.Force:=True;
'I': Flags.Interact:=True;
'J': Flags.JustName:=True;
'O': Flags.Override:=True;
'Q': Flags.Query:=True;
'V': Flags.Verbose:=True;
'X': Include:=not Include;
'L': if TempMode=None then TempMode:=List
else begin writeln('parse: mode already set ',Param);halt(1) end;
'E': if TempMode=None then TempMode:=Extract
else begin writeln('parse: mode already set ',Param);halt(1) end;
'A': if TempMode=None then TempMode:=Add
else begin writeln('parse: mode already set ',Param);halt(1) end;
'R': if TempMode=None then TempMode:=Remove
else begin writeln('parse: mode already set ',Param);halt(1) end;
'N': if TempMode=None then TempMode:=Rename
else begin writeln('parse: mode already set ',Param);halt(1) end;
else begin writeln('parse: unknown parameter ',Param);halt(1) end;
end
else if Param[1]='@' then
if Length(Param)=1 then begin Writeln('parse: no file specified ',Param);halt(1) end
else
FromFile(Param,Include,TempSpec)
else
if Length(MainPAK)=0 then
MainPAK:=MakePakFilename(Param)
else
AddFilespec(Param,Include,TempSpec);
end;
if TempMode=None then begin writeln('parse: no operating mode specified'); halt(1) end;
if MainPAK ='' then begin writeln('parse: no .PAK file specified'); halt(1) end;
{
if (not exist('QUAKE.EXE')) and (not Flags.Override) then begin
writeln('safety: You must run xpak in the same directory as QUAKE.EXE'); halt(3) end;
} {old qtest thing}
CheckParams:=TempMode;
end;
function StripPath(bigstr: string):string;
var
i: integer;
last: integer;
begin
if Length(bigstr)=0 then begin StripPath:='';exit end;
last:=0;
for i:=1 to Length(bigstr) do
if (bigstr[i]='\') or (bigstr[i]='/') then last:=i;
StripPath:=Copy(bigstr,i+1,255);
end;
function Match(TestStr:string; SpecList: PFileSpecList):boolean;
var
Matched: boolean;
ListTemp: PFileSpecList;
begin
cvForeslash(testStr);Lower4(TestStr);
ListTemp:=SpecList^.Next;
if ListTemp=nil then Match:=True else Match:=False;
while ListTemp<>nil do
begin
if WildCardMatch(StripPath(ListTemp^.Lumpname),TestStr) then
Match:=ListTemp^.Included;
if WildCardMatch(ListTemp^.Lumpname,TestStr) then{in wildmat.tpu}
Match:=ListTemp^.Included;
ListTemp:=ListTemp^.Next;
end;
end;
function GetEntry(srch:string;ListTemp:PMasterDir):PMasterDir;
var
fn:string;
begin
GetEntry:=nil;
cvForeslash(srch);Lower4(srch);
while ListTemp<>nil do
begin
SetStr(fn,ListTemp^.Dir.Lumpname);
if srch=fn then
begin
GetEntry:=ListTemp;
exit;
end;
ListTemp:=ListTemp^.Next;
end;
end;
function OpenPak(var Handle: file; filename: string):boolean;
var
IdStr: string[4];
check: word;
begin
Assign(Handle,filename);
OpenPAK:=False;
{$I-}
Reset(Handle,1);
case IOResult of
0:;
2:begin writeln('open: file not found'); exit end;
3:begin writeln('open: path not found'); exit end;
5:begin writeln('open: access denied'); exit end;
else begin writeln('open: error accessing file'); exit end;
end;
{$I+}
IdStr[0]:=#4;
BlockRead(Handle,IdStr[1],4,check);
if check<>4 then begin writeln('open/idstr: read size mismatch. requested 4, received ',check);OpenPAK:=False end;
if IdStr<>PAK_HEADER then begin writeln('open: not a valid PAK file.'); exit end;
OpenPAK:=True;
end;
procedure WriteHeader(var pak:file);
const
Header:array[1..12] of char=PAK_HEADER+#12#0#0#0#0#0#0#0;
begin
if Flags.Verbose then writeln('writehdr: writing PAK header');
BlockWrite(pak,Header,12);
end;
function ReadDirectory(var pak: file): PMasterDir;
var
check: word;
TempDir: DirEntry;
LumpNum: word;
ListTemp: PMasterDir;
ListStart: PmasterDir;
filename: string;
begin
readDirectory:=nil;
New(ListStart);ListTemp:=ListStart;
BlockRead(pak,TempDir.Pos,4,check);
if check<>4 then begin writeln('readdir/dirpos: read size mismatch. requested 4, received ',check);exit end;
BlockRead(pak,TempDir.Size,4,check);
if check<>4 then begin writeln('readdir/dirsize: read size mismatch. requested 4, received ',check);exit end;
if TempDir.Size=0 then exit;
if Flags.Verbose then writeln('readdir: reading PAK directory');
Seek(pak,TempDir.Pos);
for LumpNum:=1 to TempDir.Size div SizeOf(DirEntry) do
begin
BlockRead(pak,TempDir,SizeOf(DirEntry),check);
if check<>SizeOf(DirEntry) then
begin writeln('readdir/entries: read size mismatch. requested ',SizeOf(DirEntry),' received ',check);exit end;
SetStr(filename,TempDir.Lumpname);
cvBackslash(filename);
New(ListTemp^.Next);
ListTemp^.Next^.Prev:=ListTemp;
ListTemp^.Next^.Next:=nil;
ListTemp:=ListTemp^.Next;
ListTemp^.Dir:=TempDir;
ListTemp^.Filename:=filename;
end;
ListTemp:=ListStart^.Next;
ListTemp^.Prev:=nil;
Dispose(ListStart);
ReadDirectory:=ListTemp;
end;
function CreateDirectory(Files:PFileSpecList):PMasterDir;
var
MstrTemp: PMasterDir;
MstrStart: PMasterDir;
MstrMatch: PMAsterDir;
SpecTemp: PFileSpecList;
TempStr,TempFile: string;
DirInfo: SearchRec;
p:DirStr; f:NameStr; e:ExtStr;
begin
New(MstrStart);MstrTemp:=MstrStart;MstrTemp^.Next:=nil;
SpecTemp:=Files^.Next;
while SpecTemp<>nil do
begin
TempStr:=SpecTemp^.Filespec;
cvBackslash(TempStr);
FSplit(TempStr,p,f,e);
FindFirst(Tempstr,Anyfile-Directory-Hidden-VolumeID,DirInfo);
while DosError=0 do
begin
TempFile:=p+DirInfo.Name;
cvForeSlash(TempFile);Lower4(TempFile);
MstrMatch:=nil;
if SpecTemp^.Remapped then
begin
MstrMatch:=GetEntry(SpecTemp^.Lumpname,MstrStart);
if MstrMatch<>nil then
begin
MstrMatch^.Filename:=p+DirInfo.Name;
MstrTemp^.Dir.Size:=DirInfo.Size;
end;
TempFile:=SpecTemp^.Lumpname;
end;
if MstrMatch=nil then
begin
New(MstrTemp^.Next);
MstrTemp^.Next^.Prev:=MstrTemp;
MstrTemp:=MstrTemp^.Next;
MstrTemp^.Next:=nil;
MstrTemp^.Filename:=p+DirInfo.name;
SetArr(MstrTemp^.Dir.Lumpname,Tempfile);
MstrTemp^.Dir.Size:=DirInfo.Size;
MstrTemp^.Dir.Pos:=0;
end;
FindNext(DirInfo);
end;
SpecTemp:=SpecTemp^.Next;
end;
MstrTemp:=MstrStart^.Next;
MstrTemp^.Prev:=nil;
Dispose(MstrStart);
CreateDirectory:=MstrTemp;
end;
function WriteDirectory(var pak:file;ListTemp:PMasterDir): boolean;
var
DirPos,DirLen: Longint;
check:word;
begin
WriteDirectory:=False;
seek(pak,FileSize(pak));
DirPos:=FilePos(pak);
if Flags.Verbose then writeln('writedir: writing new PAK directory');
DirLen:=0;
while ListTemp<>nil do
begin
BlockWrite(pak,ListTemp^.Dir,Sizeof(DirEntry),check);
if check<SizeOf(DirEntry) then begin
writeln('writedir: write size mismatch. requested ',SizeOf(DirEntry),' wrote ',check,'. out of disk space?');
close(pak); exit end;
Inc(DirLen,SizeOf(DirEntry));
ListTemp:=ListTemp^.Next;
end;
Seek(pak,4);
BlockWrite(pak,DirPos,4);
BlockWrite(pak,DirLen,4);
WriteDirectory:=True;
end;
procedure CropDirectory(var pak:file);
var
DirPos,DirLen:LongInt;
begin
Reset(pak,1);
Seek(pak,4);
BlockRead(pak,DirPos,4);
BlockRead(pak,DirLen,4);
Seek(pak,DirPos);
Truncate(pak);Close(pak);Reset(pak,1);
end;
procedure RemapFilenames(MstrList:PMasterDir; Filespec:PFilespecList);
var
SpecTemp: PFileSPecList;
lumpname: string;
begin
while MstrList<>nil do
begin
SetStr(lumpname,MstrList^.Dir.Lumpname);
SpecTemp:=FileSpec;
while SpecTemp<>nil do
begin
if SpecTemp^.Remapped then
if lumpname=SpecTemp^.Lumpname then
MstrList^.Filename:=SpecTemp^.filespec;
SpecTemp:=SpecTemp^.Next;
end;
MstrList:=MstrList^.Next;
end;
end;
procedure MakePath(const pname: string);
var
slashpos: byte;
TempStr: string;
begin
{$I-}
for slashpos:=1 to Length(pname) do
if pname[slashpos]='\' then
begin
TempStr:=Copy(Pname,1,slashpos-1);
mkdir(TempStr);
if IOResult=0 then
if Flags.Verbose then
begin
cvForeslash(tempstr);Lower4(tempstr);
writeln('mkdir: ',TempStr);
end;
end;
{$I+}
end;
procedure BAKFile(Filename:string);
var
p:Dirstr;n:NameStr;e:extstr;
NewName:String;
Regs:Registers;
begin
if Flags.Verbose then writeln('backup: ',Filename);
FSplit(Filename,p,n,e);
NewName:=p+n+'.bak'+#0;
Filename:=Filename+#0;
Regs.AH := $56;
Regs.DS := Seg(FileName);
Regs.DX := Ofs(FileName) + 1;
Regs.ES := Seg(NewName);
Regs.DI := Ofs(NewName) + 1;
MsDos(Regs);
end;
function CopyData(var src,dest: file; Amount:LongInt):boolean;
var
Buf: ^Buffer;
BlockSize:word;
check:word;
begin
CopyData:=False;
New(buf);
If Flags.Debug then writeln('copy: copying ',Amount,' bytes. srcpos=',FilePos(src),' destpos=',FilePos(dest));
While Amount>0 do
begin
if Amount>MAX_BLOCK_SIZE then
BlockSize:=MAX_BLOCK_SIZE
else
BlockSize:=Amount;
Dec(Amount,BlockSize);
BlockRead(src,buf^,Blocksize,check);
if check<>BlockSize then begin
writeln('copy: read size mismatch. requested ',BlockSize,' received ',check);
Dispose(Buf);exit end;
BlockWrite(dest,buf^,Blocksize,check);
if check<>BlockSize then begin
writeln('copy: write size mismatch. requested ',Blocksize,' wrote ',check,'. out of disk space?');
Dispose(Buf);exit end;
end;
Dispose(buf);
CopyData:=True;
end;
function MoveData(var handle:file;fPos,Size,Offset:LongInt):boolean;
var {rPos is startpos}
Buf: ^Buffer; {rSize is amout to move}
Blocksize:Longint; {rOffset is amount to move by, +/-}
EndPos:Longint;
check:word;
begin
if (Size=0) or (Offset=0) then begin MoveData:=True;exit end;
MoveData:=False;
New(Buf);
If Flags.Debug then writeln('move: moving ',Size,' bytes from ',fPos,' by ',Offset,' bytes. (to ',fpos+Offset,')');
if Offset>0 then Inc(fPos,Size);
while Size>0 do
begin
if Size>MAX_BLOCK_SIZE then
BlockSize:=MAX_BLOCK_SIZE
else
BlockSize:=Size;
Dec(Size,BlockSize);
if OffSet>0 then
Seek(Handle,fpos-BlockSize)
else
Seek(handle,fPos);
BlockRead(handle,Buf^,Blocksize,check);
if check<>BlockSize then begin
writeln('move: read size mismatch. requested ',Blocksize,' received ',check);
Dispose(Buf);Close(handle);exit end;
Seek(handle,Filepos(Handle)-BlockSize+Offset);
BlockWrite(handle,buf^,Blocksize,check);
if check<>BlockSize then begin
writeln('delete: write size mismatch. requested ',Blocksize,' wrote ',check,'. out of disk space?');
Dispose(Buf);Close(handle); exit end;
if Offset>0 then
Dec(fpos,BlockSize)
else
Inc(fpos,BlockSize);
end;
Dispose(Buf);
MoveData:=True;
end;
procedure ListLump(Entry: DirEntry);
var
TempStr: string;
DispStr: string[40];
begin
SetStr(TempStr,Entry.Lumpname);
if Flags.JustName then
Writeln(TempStr)
else
begin
FillChar(DispStr[1],40,' ');
DispStr:=TempStr;
DispStr[0]:=#40;
Write(DispStr);
Write('Pos=',Entry.Pos:8);
Writeln(' Size=',Entry.Size:8,' (bytes)');
end;
end;
procedure ExtractLump(var pak:file;const Entry: PMasterDir);
var
lname:string;
op: file;
ky:char;
tempstr:string;
begin
SetStr(lname,Entry^.Dir.Lumpname);
MakePath(Entry^.Filename);
tempstr:=Entry^.Filename;cvForeslash(tempstr);Lower4(tempstr);
if not Flags.Force then
if exist(Entry^.Filename) then
if Flags.Interact then
begin
write('extract: overwrite file ',tempstr,'? [ynasq]');
ky:=ReadKey;
case UpCase(ky) of
'N':;
'A':Flags.Force:=True;
'S':Flags.Interact:=False;
'Q':halt(HALT_QUIT);
'Y':;
else ky:='n';
end;
writeln(ky);
if UpCase(ky)='N' then exit;
end
else
begin
writeln ('extract: ',tempstr,' exists. skipping');
exit
end;
if Flags.BAckup then
if Exist(Entry^.Filename) then
BAKFile(Entry^.Filename);
if Flags.Verbose then
if tempstr=lname then
writeln('extract: ',lname)
else
writeln('extract: ',lname,' from file ',tempstr);
Assign(op,Entry^.Filename);
Rewrite(op,1);
if IOResult<>0 then begin writeln('extract: unable to open ',tempstr); exit end;
Seek(pak,Entry^.Dir.Pos);
CopyData(pak,op,Entry^.Dir.Size);
Close(op);
end;
function AddLump(var Handle: file; Filename: string):Longint;
var
ip: file;
buf: ^Buffer;
BlockSize: word;
check: word;
begin
AddLump:=0;
New(buf);
Assign(ip,Filename);
ReSet(ip,1);
AddLump:=FileSize(Handle);
Seek(Handle,FileSize(Handle));
while not eof(ip) do
begin
BlockRead(ip,buf^,MAX_BLOCK_SIZE,BlockSize);
BlockWrite(Handle,buf^,BlockSize,check);
if check<BlockSize then begin
writeln('addlump: write size mismatch. Requested ',SizeOf(DirEntry),' wrote ',check,'. out of disk space?');
Dispose(Buf);Close(Handle);close(ip);AddLump:=0; exit end;
end;
Dispose(buf);
Close(ip);
end;
function UpdateLump(var pak:file;Entry:PMasterDir;ListTemp:PMasterDir):boolean;
var
lumpname,tempstr: string;
ip: file;
begin
UpdateLump:=False;
SetStr(Lumpname,Entry^.Dir.Lumpname);
if Flags.Verbose then
begin
tempstr:=Entry^.filename;cvForeslash(Tempstr);Lower4(tempstr);
writeln('update: ',lumpname,' with file ',tempstr);
end;
Assign(ip,Entry^.Filename);
ReSet(ip,1);
if not MoveData(pak,Entry^.Dir.Pos+Entry^.Dir.Size,
FileSize(pak)-Entry^.Dir.Pos-Entry^.Dir.Size,
FileSize(ip)-Entry^.Dir.Size) then begin
writeln('update: error moving data in PAK file.');Close(ip);exit end;
Seek(pak,Entry^.Dir.Pos);
if not CopyData(ip,pak,FileSize(ip)) then begin
writeln('update: error reading from file.');close(ip);exit end;
if FileSize(ip) < Entry^.Dir.Size then
begin
Seek(pak,FileSize(pak)+FileSize(ip)-Entry^.Dir.Size);
Truncate(pak);Close(pak);Reset(pak,1);
end;
While ListTemp<>nil do
begin
if ListTemp^.Dir.Pos>Entry^.Dir.Pos then
if ListTemp^.Dir.Pos<>0 then
Inc(ListTemp^.Dir.Pos,FileSize(ip)-Entry^.Dir.Size)
else
else if ListTemp^.Dir.Pos=Entry^.Dir.Pos then
ListTemp^.Dir.Size:=FileSize(ip); {Original record}
ListTemp:=ListTemp^.Next;
end;
Close(ip);
UpdateLump:=true;
end;
procedure RemoveLump(var pak:file;Lump: PMasterDir; var MasterDir:PMasterDir);
var
ListTemp : PMasterDir;
begin
if Lump=nil then exit;
if Lump^.Prev=nil then
begin
Lump:=MasterDir;
MasterDir:=Lump^.Next;
MasterDir^.Prev:=nil
end
else
begin
Lump^.Prev^.Next:=Lump^.Next;
if Lump^.Next<>nil then Lump^.Next^.Prev:=Lump^.Prev;
end;
if not MoveData(pak,Lump^.Dir.Pos+Lump^.Dir.Size,
FileSize(pak)-Lump^.Dir.Pos-Lump^.Dir.Size,
-Lump^.Dir.Size)
then begin writeln('remove: error moving data in PAK file.'); exit end;
Seek(pak,FileSize(pak)-Lump^.Dir.Size);
Truncate(pak);Close(pak);Reset(pak,1);
ListTemp:=MasterDir;
while ListTemp<>nil do
begin
if ListTemp^.Dir.Pos>Lump^.Dir.Pos then
Dec(ListTemp^.Dir.Pos,Lump^.Dir.Size);
ListTemp:=ListTemp^.Next;
end;
Dispose(Lump);
end;
procedure SafetyPAK(pakfile:string);
var
pakname: string;
begin
if not Flags.OverRide then
begin
lower4(pakfile);
pakname:=StripPath(pakfile);
if pakname='pak0.pak' then
begin writeln('safety: will not write to PAK0.PAK'); halt(HALT_SAFETY) end;
if pakname='pak1.pak' then
begin writeln('safety: will not write to PAK1.PAK'); halt(HALT_SAFETY) end;
end;
end;
procedure ListPAK(pakfile:string;filespec:PFilespecList);
var
ListTemp:PMasterDir;
pak: file;
lumpname: string;
begin
if not OpenPAK(pak,pakfile) then exit;
ListTemp:=ReadDirectory(pak);
Close(pak);
while ListTemp<>nil do
begin
SetStr(lumpname,ListTemp^.Dir.Lumpname);
if Match(lumpname,FileSpec) then
ListLump(ListTemp^.Dir);
ListTemp:=ListTemp^.Next;
end;
end;
procedure ExtractPAK(pakfile:string;filespec:PFilespecList);
var
ListTemp: PMasterDir;
pak:file;
lumpname: string;
begin
if not OpenPAK(pak,pakfile) then exit;
ListTemp:=ReadDirectory(pak);
RemapFilenames(ListTemp,filespec);
while ListTemp<>nil do
begin
SetStr(lumpname,ListTemp^.Dir.Lumpname);
if Match(lumpname,filespec) then
ExtractLump(pak,ListTemp);
ListTemp:=ListTemp^.Next;
end;
end;
procedure AddPAK(pakfile:string;filespec:PFilespecList);
var
ListPrev,ListTemp,OldEntry:PMasterDir;
pak:file;
MstrStart: PMasterDir;
NewStart: PMAsterDir;
srcfile,srclump:string;
tempstr:string;
ky: char;
SkipUpdate: boolean;
begin
SafetyPAK(pakfile);
SkipUpdate:=False;
if not exist(pakfile) then
begin
Assign(pak,pakfile);ReWrite(pak,1);
WriteHeader(pak);Close(pak);
end;
if not OpenPAK(pak,pakfile) then exit;
NewStart:=CreateDirectory(filespec); {Get New lumps}
MstrStart:=ReadDirectory(pak); {Get original directory}
ListPrev:=MstrStart;
if ListPrev<>nil then
begin
while ListPrev^.Next<>nil do
ListPrev:=ListPrev^.Next;
ListPrev^.Next:=NewStart;
NewStart^.Prev:=ListPrev; {Paste New lumps onto end of original}
end
else
begin
MstrStart:=NewStart;
NewStart^.Prev:=nil;
end;
CropDirectory(pak);
ListTemp:=NewStart;
while ListTemp<>nil do
begin
srcfile:=ListTemp^.Filename;
SetStr(srclump,ListTemp^.Dir.Lumpname);
OldEntry:=GetEntry(srclump,MstrStart);
if OldEntry = ListTemp then
begin
if Flags.Verbose then
begin
tempstr:=srcfile;cvForeslash(tempstr);Lower4(tempstr);
if tempstr=srclump then
writeln('add: ',srclump)
else
writeln('add: ',srclump,' from file ',tempstr);
end;
ListTemp^.Dir.Pos:=AddLump(pak,srcfile);
if ListTemp^.Dir.Pos=0 then
begin
ListPrev^.Next:=ListTemp^.Next;
if ListTemp^.Next<>nil then
ListTemp^.Next^.Prev:=ListPrev;
ListTemp:=ListTemp^.Next;
end
else
begin
Listprev:=ListTemp;
ListTemp:=ListTemp^.Next;
end
end
else
begin
ky:='Y';
if SkipUpdate then
begin
ky:='N';
if Flags.Verbose then writeln('update: skipping ',srclump);
end;
if Flags.Interact then
begin
write('update: update lump ',srclump,'? [ynasq]');
ky:=ReadKey;
case UpCase(ky) of
'A':Flags.Interact:=False;
'S':begin SkipUpdate:=True; if Flags.Verbose then writeln('update: skipping ',srclump);end;
'Q':halt(HALT_QUIT);
'Y':;
else ky:='n';
end;
writeln(ky);
end;
ListTemp^.Dir:=OldEntry^.Dir;
if (UpCase(ky)='Y') or (UpCase(ky)='A') then
if UpdateLump(pak,ListTemp,MstrStart) then
begin
ListPrev^.Next:=ListTemp^.Next;
Dispose(ListTemp);
ListTemp:=ListPrev^.Next;
if ListTemp<>nil then ListTemp^.Prev:=ListPrev;
end;
end;
end;
WriteDirectory(pak,MstrStart);
Close(pak);
end;
procedure RemovePAK(pakfile:string;filespec:PFilespecList);
var
pak:file;
ListTemp:PMasterDir;
MstrStart :PMasterDir;
DirLen,DirPos: Longint;
lumpname: string;
begin
SafetyPAK(pakfile);
if not OpenPAK(pak,pakfile) then exit;
MstrStart:=ReadDirectory(pak);
if Filespec=nil then writeln('remove: no entries to process');
CropDirectory(pak);
ListTemp:=MstrStart;
while ListTemp<>nil do
begin
SetStr(lumpname,ListTemp^.Dir.Lumpname);
if Match(lumpname,Filespec) then
begin
if Flags.Verbose then writeln('remove: ',lumpname);
RemoveLump(pak,ListTemp,MstrStart);
end;
ListTemp:=ListTemp^.Next;
end;
WriteDirectory(pak,MstrStart);
Close(pak);
end;
procedure RenamePAK(pakfile:string;filespec:PFilespecList);
var
MstrStart: PMasterDir;
MstrTemp:PMasterDir;
SpecTemp: PFileSPecList;
lumpname,newname: string;
pak: file;
begin
SafetyPAK(pakfile);
if not OpenPAK(pak,pakfile) then exit;
MstrStart:=ReadDirectory(pak);
MstrTemp:=MstrStart;
while MstrTemp<>nil do
begin
SetStr(lumpname,MstrTemp^.Dir.Lumpname);
SpecTemp:=FileSpec;
while SpecTemp<>nil do
begin
if SpecTemp^.Remapped then
if lumpname=SpecTemp^.Lumpname then
begin
newname:=SpecTemp^.Filespec;
cvForeslash(newname);Lower4(newname);
SetArr(MstrTemp^.Dir.Lumpname,newname);
if Flags.Verbose then
writeln('rename: ',lumpname,' to ',newname);
end;
SpecTemp:=SpecTemp^.Next;
end;
MstrTemp:=MstrTemp^.Next;
end;
CropDirectory(pak);
WriteDirectory(pak,MstrStart);
Close(pak);
end;
var
pakfile:string;
filespec:PFileSpecList;
begin
DirectVideo:=False;
Assign(Output,'');ReWrite(Output);
Writeln('# XPak v0.4.1; 96/09/30. (c) Tom Wheeley; <splitbung>, tomw@tsys.demon.co.uk; '#13#10);
Case CheckParams(pakfile,filespec) of
List: ListPAK(pakfile,filespec);
Extract: ExtractPAK(pakfile,filespec);
Add: AddPAK(pakfile,filespec);
Remove: RemovePAK(pakfile,filespec);
Rename: RenamePAK(pakfile,filespec);
else writeln('main: mode not yet implemented');
end;
end.